;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;document-menu.lisp
;;
;;
;;  copyright © 1987-89 Apple Computer
;;
;;  This file adds a document menu to the menubar.  The first two items
;;  allow the user to add files and remove files to/from the menu.
;;
;;  This menu is a handy way of arranging easy access to a set of files
;;  which you frequently open.
;;
;;  This code uses a file called "Pearl Documents".  It creates this file
;;  (if there isn't one) in the home; directory.  This file should always
;;  contain a list of pathnames.
;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  find the file containing the list of documents
;;  If the file doesn't exist, create one.

(defvar *document-file*
  (or (probe-file "home;Pearl Documents")
      (with-open-file (my-file "home;Pearl Documents"
                               :if-does-not-exist :create
                               :direction :output)
        (prin1 () my-file)
        "home;Pearl Documents")))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  read the list of pathnames from the file, and alphabetize it
;;  store the result in another global variable.

(defvar *document-pathnames* (with-open-file (f *document-file*)
                               (sort (read f) #'string-lessp
                                     :key #'pathname-filename)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; a new class of menu-items, specifically suited to opening files

(defobject *document-menu-item* *menu-item*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  exist automatically processes the file names into item names
;;  the action is a lexical closure, which closes over the pathname

(defobfun (exist *document-menu-item*) (init-list)
  (let* ((my-file (getf init-list :filename "hd:init.lisp")))
    (usual-exist (list
                  :menu-item-title (pathname-filename my-file)
                  :menu-item-action #'(lambda ()
                                       (ed my-file))))
    (unless (probe-file my-file)
      (menu-item-disable))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;this is where the code for building the menu begins
;;

(defvar *document-menu* (oneof *menu* :menu-title "Documents"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  add items for adding files, removing files, plus a blank line
;;

(ask *document-menu* (add-menu-items
                      (oneof *menu-item*
                             :menu-item-title "Add DocumentÉ"
                             :menu-item-action '%do-add-document)
                      (oneof *menu-item*
                             :menu-item-title "Remove DocumentÉ"
                             :menu-item-action '%do-remove-document)
                      (oneof *menu-item*
                             :menu-item-title "-")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  this function is called to add a document to the menu.

(defun %do-add-document ()
  (let* ((new-file (choose-file-dialog :file-type "TEXT")))
    (ask *document-menu* 
      (add-menu-items
       (oneof *document-menu-item*
              :filename new-file)))
    (push new-file *document-pathnames*)
    (update-doc-menu-file)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  this function is called to remove a document from the menu.

(defun %do-remove-document ()
  (let* ((old-file (select-item-from-list (mapcar #'pathname-filename
                                                  *document-pathnames*)))
         (old-menu-item (ask *document-menu*
                          (find-menu-item old-file))))
    (when old-menu-item
      (ask *document-menu*
        (remove-menu-items old-menu-item))
      (setq *document-pathnames*
            (delete old-file *document-pathnames*
                    :test #'equal
                    :key #'pathname-filename))
      (update-doc-menu-file))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  modify the file holding the list of files

(defun update-doc-menu-file ()
  (with-open-file (f *document-file*
                     :direction :output
                     :if-exists :supersede)
    (let ((*print-length* nil)
          (*print-level* nil))
      (pprint *document-pathnames* f))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  install a series of menu-items for all the current files

(ask *document-menu*
  (dolist (filename *document-pathnames*)
    (add-menu-items (oneof *document-menu-item*
                           :filename filename))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  install the menu

(ask *document-menu* (menu-install))
